{
  Copyright 2012 Sergey Ostanin

  Licensed under the Apache License, Version 2.0 (the "License");
  you may not use this file except in compliance with the License.
  You may obtain a copy of the License at

      http://www.apache.org/licenses/LICENSE-2.0

  Unless required by applicable law or agreed to in writing, software
  distributed under the License is distributed on an "AS IS" BASIS,
  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
  See the License for the specific language governing permissions and
  limitations under the License.
}

unit PadWidget;

interface

uses
  Classes, SysUtils, Pad, Controls, Windows, VisualUtils, Graphics, Math,
  MiscUtils, Types, Clipbrd, Forms, LCLType, Usp, Menus, Dialogs, imm;

type
  TPadWidget = class;
  TPadLine = class;
  TPadLineList = TGenericObjectList<TPadLine>;
  TPadBlock = class;
  TPadBlockList = TGenericObjectList<TPadBlock>;
  TGraphicPadBlock = class;
  TPadClipboardFormat = (pcfFragment, pcfBitmap, pcfText);
  TPadClipboardFormats = set of TPadClipboardFormat;
  TInsertEvent = procedure(Sender: TPadWidget; Position: Integer; Fragment: TPad) of object;
  TDeleteEvent = procedure(Sender: TPadWidget; Position, Len: Integer) of object;

  TPadWidget = class(TCustomControl)
  private const
    WM_PAD_UPDATE_CARET = WM_USER + 1;
    BORDER_WIDTH = 1;
  private type
    TPositionDescriptor = record
      Origin: TPoint;
      Height: Integer;
      LineIndex: Integer;
      LineTop: Integer;
    end;
    TPadPosition = (ppBefore, ppLine, ppAfter);
    TScreenPos = record
      x: Integer;
      Line: Integer;
    end;
  private
    FModel: TPad;

    FMargin: Integer;
    FSpacing: Integer; { interline spacing in pixels }
    FBorder: Boolean;
    FReadOnly: Boolean;

    FLines: TPadLineList;

    FCaretCharPos: Integer; { 0 <= FCaretCharPos <= CharCount }
    FCaretX: Integer;
    FShowCaretInReadOnly: Boolean;
    FCaretUpdateQueued: Boolean;

    FLayoutValid: Boolean;
    FLaidOutSize: TSize;
    FRawHeight: Integer; { valid when FLayoutValid = TRUE }
    FLayingOut: Boolean;

    FSelStart: Integer;
    FSelLength: Integer;

    FMouseDown: Boolean;
    FMouseDownPos: TPoint;
    FMouseListeners: TMouseListenerList;

    FOnInsert: TInsertEvent;
    FOnDelete: TDeleteEvent;

    FPopupMenu: TPopupMenu;
    FPopupMenuImages: TImageList;
    class function MakeScreenPos(x, Line: Integer): TScreenPos;
    function GetLineCount: Integer;
    procedure LayOut;
    procedure SetMargin(Value: Integer);
    procedure SetSpacing(Value: Integer);
    procedure SetReadOnly(Value: Boolean);
    function CharPosToLine(CharPos: Integer): TPadLine;
    function CharPosToBlockPos(CharPos: Integer; out BlockCharPos: Integer): TPadBlock;
    function CharPosToBlock(CharPos: Integer): TPadBlock;
    function YToLine(y: Integer): TPadLine;
    function ScreenPosToCharPos(ScreenPos: TScreenPos): Integer;
    function CharPosToScreenPos(CharPos: Integer): TScreenPos;
    procedure SetCaretCharPos(Value: Integer);
    function GetCaretScreenPos: TScreenPos;
    procedure OffsetCaretLine(Offset: Integer);
    procedure LayoutNeeded;
    procedure InvalidateLayout;
    procedure MoveCaretByPage(Down: Boolean);
    function YToLineEx(y: Integer; out Position: TPadPosition): TPadLine;
    function LineXToBlock(Line: TPadLine; x: Integer): TPadBlock;
    function GetCharCount: Integer;
    function InternalGetContentHeight: Integer;
    procedure InvalidateCaret;
    procedure SetShowCaretInReadOnly(Value: Boolean);
    function GetContentHeight: Integer;
    procedure SetBorder(Value: Boolean);
    procedure SetSelStart(Value: Integer);
    procedure SetSelLength(Value: Integer);
    function CanSelect: Boolean;
    procedure Navigate(Select: Boolean; CharPos: Integer; XPos: Integer = -1);
    procedure UpdateCursor;
    procedure MoveCaret(CharPos: Integer; XPos: Integer = -1);
    function GetCaretLine: TPadLine;
    procedure MoveCaretXY(Select: Boolean; const p: TPoint);
    procedure TimerTick;
    procedure GetSpacingsForLine(LineIndex: Integer; out TopSpacing, BottomSpacing: Integer);
    function DescribePosition(CharPos: Integer): TPositionDescriptor;
    function ImeActive: Boolean;
    procedure WMUpdateCaret(var Message: TMessage); message WM_PAD_UPDATE_CARET;
    procedure WMImeStartComposition(var Message: TMessage); message WM_IME_STARTCOMPOSITION;
    procedure WMImeEndComposition(var Message: TMessage); message WM_IME_ENDCOMPOSITION;
    procedure StartTimer;
    procedure StopTimer;
    function GetPreviousBlock(Block: TPadBlock): TPadBlock;
    function GetNextBlock(Block: TPadBlock): TPadBlock;
    function HasSpecialEof: Boolean;
    function GetHasSelection: Boolean;
    procedure ModelChange(Sender: TObject);
    procedure ModelEndModify(Sender: TObject);
    function GetAdjacentCharPos(CharPos: Integer; Next: Boolean): Integer;
    procedure SelectAllClick(Sender: TObject);
    function AddPopupMenuItem(const Caption, ImageResourceName: String; ShortCut: TShortCut;
      OnClick: TNotifyEvent): TMenuItem;
    procedure CutClick(Sender: TObject);
    procedure CopyClick(Sender: TObject);
    procedure PasteClick(Sender: TObject);
    procedure DeleteClick(Sender: TObject);
    procedure OpenImageClick(Sender: TObject);
    procedure SaveImageClick(Sender: TObject);
  protected
    procedure Paint; override;
    procedure Resize; override;
    procedure KeyDown(var Key: Word; Shift: TShiftState); override;
    procedure UTF8KeyPress(var UTF8Key: TUTF8Char); override;
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
    procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
    procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
    procedure SetParent(Parent: TWinControl); override;
    procedure WMKillFocus(var Message: TWMKillFocus); message WM_KILLFOCUS;
    procedure WMSetFocus(var Message: TWMSetFocus); message WM_SETFOCUS;
    procedure CreateParams(var Params: TCreateParams); override;
    procedure CreateHandle; override;
    procedure DestroyHandle; override;
    procedure WMTimer(var Message: TWMTimer); message WM_TIMER;
    procedure WMEraseBkgnd(var Message: TWMEraseBkgnd); message WM_ERASEBKGND;
    procedure CalculatePreferredSize(var PreferredWidth,
      PreferredHeight: Integer; WithThemeSpace: Boolean); override;
    procedure DoContextPopup(MousePos: TPoint; var Handled: Boolean); override;
  public
    constructor Create(Owner: TComponent); override;
    destructor Destroy; override;
    procedure InsertObjectAtCaretPos(Obj: TPadObject);
    procedure SelectNothing;
    procedure SelectAll;
    procedure DeleteFragment(StartChar, Len: Integer);
    procedure DeleteSelection;
    procedure GetFragment(StartChar, Len: Integer; Pad: TPad);
    procedure GetSelection(Pad: TPad);
    procedure InsertFragment(CharPos: Integer; Pad: TPad);
    procedure InsertFragmentAtCaretPos(Pad: TPad);
    procedure CopyToClipboard;
    procedure CutToClipboard;
    function CaretEnabled: Boolean;
    procedure PasteText;
    procedure PasteFragment;
    procedure PasteBitmap;
    function GetAvailableClipboardFormats: TPadClipboardFormats;
    procedure PasteFormat(Fmt: TPadClipboardFormat; ReplaceSelection: Boolean);
    procedure Paste(ReplaceSelection: Boolean);
    function GetBestAvailableClipboardFormat(out Fmt: TPadClipboardFormat): Boolean;
    function SelectedGraphicBlock: TGraphicPadBlock;
    procedure AddMouseListener(const Listener: IMouseListener);
    procedure RemoveMouseListener(const Listener: IMouseListener);

    property Border: Boolean read FBorder write SetBorder;
    property CaretCharPos: Integer read FCaretCharPos write SetCaretCharPos;
    property CharCount: Integer read GetCharCount;
    property ContentHeight: Integer read GetContentHeight;
    property HasSelection: Boolean read GetHasSelection;
    property LineCount: Integer read GetLineCount;
    property Margin: Integer read FMargin write SetMargin;
    property Model: TPad read FModel;
    property OnDelete: TDeleteEvent read FOnDelete write FOnDelete;
    property OnInsert: TInsertEvent read FOnInsert write FOnInsert;
    property ReadOnly: Boolean read FReadOnly write SetReadOnly;
    property SelLength: Integer read FSelLength write SetSelLength;
    property SelStart: Integer read FSelStart write SetSelStart;
    property ShowCaretInReadOnly: Boolean read FShowCaretInReadOnly write SetShowCaretInReadOnly;
    property Spacing: Integer read FSpacing write SetSpacing;
  end;
  TPadWidgetList = TGenericObjectList<TPadWidget>;

  TPadLine = class
  private
    FIndex: Integer;
    FTop: Integer;
    FHeight: Integer; { line height not including interline spacing }
    FBlocks: TPadBlockList;
    FStartChar: Integer;
    FCharCount: Integer;
    function GetBlockCount: Integer;
  public
    constructor Create;
    destructor Destroy; override;

    property BlockCount: Integer read GetBlockCount;
  end;

  TPadBlock = class
  private
    FSource: TPadObject;
    FLine: TPadLine;
    FPosition: TPoint;
    FStartChar: Integer;
    FWidget: TPadWidget;
  protected
    procedure Draw(Canvas: TCanvas; const p: TPoint; SelStart, SelLength: Integer); virtual;
    function GetHeight: Integer; virtual; abstract;
    function GetRequiredWidth: Integer; virtual; abstract;
    function GetDesiredWidth: Integer; virtual;
    function GetCharCount: Integer; virtual; abstract;
    function XToCharPos(x: Integer): Integer; virtual;
    function CharPosToX(CharPos: Integer): Integer; virtual;
    function GetAdjacentCharPos(CharPos: Integer; Next: Boolean): Integer; virtual;
  public
    constructor Create(Source: TPadObject; Widget: TPadWidget);

    property Source: TPadObject read FSource;
  end;

  TTextPadBlock = class(TPadBlock)
  private
    FStartPos: Integer;
    FLen: Integer;
    FCharAttrs: array of SCRIPT_LOGATTR;
    function GetSource: TTextPadObject;
    function GetText: UnicodeString;
  protected
    procedure Draw(Canvas: TCanvas; const p: TPoint; SelStart, SelLength: Integer); override;
    function GetHeight: Integer; override;
    function GetRequiredWidth: Integer; override;
    function GetDesiredWidth: Integer; override;
    function GetCharCount: Integer; override;
    function XToCharPos(x: Integer): Integer; override;
    function CharPosToX(CharPos: Integer): Integer; override;
    function GetAdjacentCharPos(CharPos: Integer; Next: Boolean): Integer; override;
  public
    constructor Create(Source: TPadObject; Widget: TPadWidget; StartPos, Len: Integer;
      CharAttrs: PSCRIPT_LOGATTR);

    property Source: TTextPadObject read GetSource;
    property Text: UnicodeString read GetText;
  end;

  TGraphicPadBlock = class(TPadBlock)
  private
    FWidth: Integer;
    FHeight: Integer;
    FExtension: String;
    FValidImage: Boolean;
    function GetHorizontalSpacing: Integer;
    function GetSource: TGraphicPadObject;
  protected
    function GetHeight: Integer; override;
    function GetRequiredWidth: Integer; override;
    procedure Draw(Canvas: TCanvas; const p: TPoint; SelStart, SelLength: Integer); override;
    function GetCharCount: Integer; override;
    function XToCharPos(x: Integer): Integer; override;
  public
    constructor Create(Source: TPadObject; Widget: TPadWidget);

    property Extension: String read FExtension;
    property Height: Integer read FHeight;
    property Source: TGraphicPadObject read GetSource;
    property ValidImage: Boolean read FValidImage;
    property Width: Integer read FWidth;
  end;

  TLineFeedPadBlock = class(TPadBlock)
  protected
    function GetHeight: Integer; override;
    function GetRequiredWidth: Integer; override;
    procedure Draw(Canvas: TCanvas; const p: TPoint; SelStart, SelLength: Integer); override;
    function GetCharCount: Integer; override;
  end;

function CreateGraphic(const ImageFormat, ImageData: String): TGraphic;

implementation

{$R *.rc}

resourcestring
  SCopyToClipboardError = 'Error when copying to clipboard.';
  SCut = 'Cut';
  SCopy = 'Copy';
  SPaste = 'Paste';
  SDelete = 'Delete';
  SSelectAll = 'Select All';
  SOpenImage = 'Insert Picture from File...';
  SInsertImage = 'Insert Picture';
  SOpenImageFilter = 'Pictures (*.jpg; *.jpeg; *.png; *.bmp)|*.jpg;*.jpeg;*.png;*.bmp|All Files|*.*';
  SUnknownExtension = 'Unknown file type: "%s".';
  SFileLoadingError = 'Can''t open file "%s": %s';
  SSaveImage = 'Save Picture to File...';
  SSaveImageFilter = '%s Files|*.%s|All Files|*.*';
  SSaveImageDialogTitle = 'Save Picture';

const
  FRAGMENT_FORMAT = 'application/x-irenproject.ru-pad';
  PNG_FORMAT = 'PNG';
  SOURCE_FORMATS: array [0..2] of String = (
    'Rich Text Format', 'Office Drawing Shape Format', 'Drawing Format');
  MOUSE_SELECT_THRESHOLD = 4;
  BAD_IMAGE_PLACEHOLDER_SIZE = 64;
  BAD_IMAGE_PLACEHOLDER_COLOR = clMedGray;

function BmpToPng(Bitmap: TBitmap): TPortableNetworkGraphic;
begin
  Result := TPortableNetworkGraphic.Create;
  try
    Result.Assign(Bitmap);
  except
    Result.Free;
    raise;
  end;
end;

function GetFragmentClipboardFormat: TClipboardFormat;
begin
  Result := RegisterClipboardFormat(FRAGMENT_FORMAT);
end;

function GetPngClipboardFormat: TClipboardFormat;
begin
  Result := RegisterClipboardFormat(PNG_FORMAT);
end;

procedure GrabSourceData(Obj: TGraphicPadObject);
var
  SourceFormat: String;
  Fmt: TClipboardFormat;
  Stream: TMemoryStream;
begin
  Obj.SourceData := '';
  Obj.SourceFormat := '';

  for SourceFormat in SOURCE_FORMATS do
  begin
    Fmt := RegisterClipboardFormat(SourceFormat);
    if Clipboard.HasFormat(Fmt) then
    begin
      Stream := TMemoryStream.Create;
      try
        if Clipboard.GetFormat(Fmt, Stream) then
        begin
          Stream.Seek(0, soFromBeginning);
          Obj.SourceData := ReadStreamTail(Stream);
          Obj.SourceFormat := SourceFormat;
        end;
      finally
        Stream.Free;
      end;

      Break;
    end;
  end;
end;

function FindGraphicClass(const ImageFormat: String): TGraphicClass;
begin
  if ImageFormat = 'PNG' then
    Result := TPortableNetworkGraphic
  else if ImageFormat = 'JPEG' then
    Result := TJPEGImage
  else
    raise Exception.CreateFmt('Unknown image format: "%s".', [ImageFormat]);
end;

function FindImageFormat(GraphicClass: TGraphicClass): String;
begin
  if GraphicClass = TPortableNetworkGraphic then
    Result := 'PNG'
  else if GraphicClass = TJPEGImage then
    Result := 'JPEG'
  else
    raise Exception.CreateFmt('Unsupported graphic class: "%s".', [GraphicClass.ClassName]);
end;

function CreateGraphic(const ImageFormat, ImageData: String): TGraphic;
var
  GraphicData: TStream;
begin
  Result := nil;
  try
    GraphicData := TStringStream.Create(ImageData);
    try
      Result := FindGraphicClass(ImageFormat).Create;
      Result.LoadFromStream(GraphicData);
    finally
      GraphicData.Free;
    end;
  except
    Result.Free;
    raise;
  end;
end;

procedure PutPadToClipboard(Pad: TPad);
var
  Stream: TMemoryStream;
  SourceFormat, Text: String;
  GraphObj: TGraphicPadObject;
  Fmt: TClipboardFormat;
  Graphic: TGraphic;
  Bitmap: TBitmap;
begin
  Clipboard.Open;
  try
    Clipboard.Clear;

    if (Pad.ObjectCount = 1) and (Pad.Objects[0] is TGraphicPadObject) then
    begin
      GraphObj := TGraphicPadObject(Pad.Objects[0]);

      { Copy image. }
      Graphic := CreateGraphic(GraphObj.ImageFormat, GraphObj.ImageData);
      try
        Bitmap := TBitmap.Create;
        try
          Bitmap.PixelFormat := pf24Bit;
          Bitmap.Width := Graphic.Width;
          Bitmap.Height := Graphic.Height;
          Bitmap.Canvas.Brush.Color := clWhite;
          Bitmap.Canvas.FillRect(0, 0, Bitmap.Width, Bitmap.Height);
          Bitmap.Canvas.Draw(0, 0, Graphic);

          Clipboard.Assign(Bitmap);
        finally
          Bitmap.Free;
        end;
      finally
        Graphic.Free;
      end;

      { Copy source. }
      for SourceFormat in SOURCE_FORMATS do
      begin
        if SameText(GraphObj.SourceFormat, SourceFormat) then
        begin
          Stream := TMemoryStream.Create;
          try
            WriteStreamString(Stream, GraphObj.SourceData);
            Stream.WriteByte(0);
            Fmt := RegisterClipboardFormat(GraphObj.SourceFormat);
            if (Fmt = 0) or not Clipboard.AddFormat(Fmt, Stream) then
              raise Exception.Create(SCopyToClipboardError);
          finally
            Stream.Free;
          end;

          Break;
        end;
      end;
    end;

    { Copy text. }
    Text := UTF8Encode(Pad.SimpleText);
    if (Text <> '') and not Clipboard.AddFormat(CF_UNICODETEXT, Pointer(Text)^, Length(Text)+1) then
      raise Exception.Create(SCopyToClipboardError);

    { Copy pad. }
    Stream := TMemoryStream.Create;
    try
      Pad.SaveToStream(Stream);
      if not Clipboard.AddFormat(GetFragmentClipboardFormat, Stream) then
        raise Exception.Create(SCopyToClipboardError);
    finally
      Stream.Free;
    end;
  finally
    Clipboard.Close;
  end;
end;

procedure CopyGraphicToGraphicObject(Graphic: TGraphic; GraphObj: TGraphicPadObject);
var
  Stream: TMemoryStream;
  ImageFormat: String;
begin
  ImageFormat := FindImageFormat(TGraphicClass(Graphic.ClassType));
  Stream := TMemoryStream.Create;
  try
    Graphic.SaveToStream(Stream);
    Stream.Seek(0, soFromBeginning);
    GraphObj.ImageData := ReadStreamTail(Stream);
  finally
    Stream.Free;
  end;
  GraphObj.ImageFormat := ImageFormat;
end;

function ObtainCachedImage(g: TGraphicPadObject): TBitmap;
var
  Bitmap: TBitmap;
  Graphic: TGraphic;
begin
  if not (g.CachedImage is TBitmap) then
  begin
    Bitmap := TBitmap.Create;
    try
      Graphic := CreateGraphic(g.ImageFormat, g.ImageData);
      try
        Bitmap.Assign(Graphic);
      finally
        Graphic.Free;
      end;
      g.CachedImage := Bitmap;

      Bitmap := nil;
    finally
      Bitmap.Free;
    end;
  end;
  Result := g.CachedImage as TBitmap;
end;

{ TPadWidget }

constructor TPadWidget.Create(Owner: TComponent);
begin
  inherited;
  FModel := TPad.Create;
  FModel.OnChange := ModelChange;
  FModel.OnEndModify := ModelEndModify;

  FLines := TPadLineList.Create;
  FMargin := 5;
  FSpacing := 2;
  Width := 300;
  Height := 200;
  Color := clWhite;
  ControlStyle := ControlStyle + [csOpaque];
  Font.Size := 12;
  Font.Name := 'Arial';
  Font.Color := clBlack;
  FMouseListeners := TMouseListenerList.Create;
  FMouseDownPos := Point(MaxInt, MaxInt);
  UpdateCursor;
  FPopupMenu := TPopupMenu.Create(nil);
  FPopupMenuImages := TImageList.Create(nil);
  FPopupMenu.Images := FPopupMenuImages;
end;

destructor TPadWidget.Destroy;
begin
  if FModel <> nil then
  begin
    FModel.OnChange := nil;
    FModel.OnEndModify := nil;
  end;

  FreeAndNil(FLines);
  FreeAndNil(FMouseListeners);
  FreeAndNil(FModel);
  FreeAndNil(FPopupMenu);
  FreeAndNil(FPopupMenuImages);
  inherited;
end;

procedure TPadWidget.KeyDown(var Key: Word; Shift: TShiftState);
var
  CaretLine: TPadLine;
  Block: TPadBlock;
  BlockCharPos, NewPos, CurrentPos: Integer;
begin
  inherited;
  CaretLine := GetCaretLine;
  case Key of
    VK_LEFT:
      if not (ssAlt in Shift) then
      begin
        NewPos := -1;
        if ssCtrl in Shift then
        begin
          if (FCaretCharPos = CharCount) and (FLines.Count > 0) then
            NewPos := FLines.Last.FBlocks.Last.FStartChar
          else
          begin
            Block := CharPosToBlockPos(FCaretCharPos, BlockCharPos);
            if Block <> nil then
            begin
              if BlockCharPos > 0 then
                NewPos := FCaretCharPos - BlockCharPos
              else
              begin
                Block := GetPreviousBlock(Block);
                if Block <> nil then
                  NewPos := Block.FStartChar;
              end;
            end;
          end;
        end
        else
          NewPos := GetAdjacentCharPos(FCaretCharPos, FALSE);
        if NewPos >= 0 then
          Navigate(ssShift in Shift, NewPos);
      end;
    VK_RIGHT:
      if not (ssAlt in Shift) then
      begin
        NewPos := -1;
        if ssCtrl in Shift then
        begin
          Block := CharPosToBlock(FCaretCharPos);
          if Block <> nil then
          begin
            Block := GetNextBlock(Block);
            if Block <> nil then
              NewPos := Block.FStartChar
            else
              NewPos := CharCount;
          end;
        end
        else
          NewPos := GetAdjacentCharPos(FCaretCharPos, TRUE);
        if NewPos >= 0 then
          Navigate(ssShift in Shift, NewPos);
      end;
    VK_UP:
      if [ssAlt, ssCtrl] * Shift = [] then
        OffsetCaretLine(-1);
    VK_DOWN:
      if [ssAlt, ssCtrl] * Shift = [] then
        OffsetCaretLine(1);
    VK_HOME:
      if not (ssAlt in Shift) then
      begin
        if ssCtrl in Shift then
          Navigate(ssShift in Shift, 0)
        else if CaretLine <> nil then
          Navigate(ssShift in Shift, CaretLine.FStartChar);
      end;
    VK_END:
      if not (ssAlt in Shift) and (CaretLine <> nil) then
      begin
        if (ssCtrl in Shift) or ((CaretLine.FIndex = FLines.Count-1) and
          not (FLines.Last.FBlocks.Last is TLineFeedPadBlock)) then
          Navigate(ssShift in Shift, CharCount)
        else
          Navigate(ssShift in Shift, CaretLine.FStartChar + CaretLine.FCharCount - 1);
      end;
    VK_PRIOR:
      if [ssAlt, ssCtrl] * Shift = [] then
        MoveCaretByPage(FALSE);
    VK_NEXT:
      if [ssAlt, ssCtrl] * Shift = [] then
        MoveCaretByPage(TRUE);
    VK_DELETE:
      if not FReadOnly and ([ssAlt, ssCtrl] * Shift = []) then
      begin
        if FSelLength > 0 then
        begin
          if ssShift in Shift then
            CutToClipboard
          else
            DeleteSelection;
        end
        else if not (ssShift in Shift) then
          DeleteFragment(FCaretCharPos, GetAdjacentCharPos(FCaretCharPos, TRUE) - FCaretCharPos);
      end;
    VK_BACK:
      if not FReadOnly and ([ssAlt, ssCtrl, ssShift] * Shift = []) then
      begin
        if FSelLength > 0 then
          DeleteSelection
        else if FCaretCharPos > 0 then
        begin
          CurrentPos := FCaretCharPos;
          CaretCharPos := GetAdjacentCharPos(FCaretCharPos, FALSE);
          DeleteFragment(FCaretCharPos, CurrentPos - CaretCharPos);
        end;
      end;
    VK_RETURN:
      if not FReadOnly and ([ssAlt, ssCtrl, ssShift] * Shift = []) then
      begin
        DeleteSelection;
        InsertObjectAtCaretPos(TLineFeedPadObject.Create);
      end;
    Ord('A'):
      if (ssCtrl in Shift) and ([ssAlt, ssShift] * Shift = []) and CanSelect then
        SelectAll;
    Ord('C'):
      if (ssCtrl in Shift) and ([ssAlt, ssShift] * Shift = []) and CaretEnabled then
        CopyToClipboard;
    Ord('X'):
      if (ssCtrl in Shift) and ([ssAlt, ssShift] * Shift = []) and not FReadOnly then
        CutToClipboard;
    Ord('V'):
      if (ssCtrl in Shift) and ([ssAlt, ssShift] * Shift = []) and not FReadOnly then
        Paste(TRUE);
    VK_INSERT:
      if (ssCtrl in Shift) and ([ssAlt, ssShift] * Shift = []) and CaretEnabled then
        CopyToClipboard
      else if (ssShift in Shift) and ([ssAlt, ssCtrl] * Shift = []) and not FReadOnly then
        Paste(TRUE);
  end;
end;

procedure GetWordBoundaries(CharAttrs: PSCRIPT_LOGATTR; CharCount: Integer; Boundaries: TIntegerList);
var
  i: Integer;
begin
  if CharCount > 0 then
  begin
    Boundaries.Add(1);
    for i := 2 to CharCount do
    begin
      Inc(CharAttrs);
      if CharAttrs^ and fSoftBreak <> 0 then
        Boundaries.Add(i);
    end;
  end;
end;

procedure TPadWidget.LayOut;
var
  y: Integer;
  x, CurObj, CurChar, RightMargin: Integer;
  CurLine: TPadLine;
  Blocks: TPadBlockList;
  Words: TIntegerList;
  Block: TPadBlock;
  Done: Boolean;
  Ctx: SCRIPT_STRING_ANALYSIS;
  CharAttrs: PSCRIPT_LOGATTR;

  procedure FinishLine;
  var
    MidLine: Integer;
    b: TPadBlock;
  begin
    if CurLine <> nil then
    begin
      MidLine := y + CurLine.FHeight div 2;
      for b in CurLine.FBlocks do
        b.FPosition.y := MidLine - b.GetHeight div 2;
      Inc(y, CurLine.FHeight + FSpacing);
      CurLine := nil;
    end;
  end;

  procedure FetchBlocks;
  var
    Obj: TPadObject;
    i, OldBlockCount: Integer;
    s: UnicodeString;
  begin
    OldBlockCount := Blocks.Count;
    while (CurObj < FModel.ObjectCount) and (Blocks.Count = OldBlockCount) do
    begin
      Obj := FModel.Objects[CurObj];
      if Obj is TTextPadObject then
      begin
        s := TTextPadObject(Obj).Text;
        if s <> '' then
        begin
          Assert( ScriptStringAnalyse(0, Pointer(s), Length(s), 0, -1,
            SSA_BREAK, 0, nil, nil, nil, nil, nil, Ctx) = S_OK );
          try
            CharAttrs := ScriptString_pLogAttr(Ctx);
            Assert( CharAttrs <> nil );
            Words.Clear;
            GetWordBoundaries(CharAttrs, Length(s), Words);
            if Words.Count > 0 then
            begin
              Words.Add(Length(s)+1);
              for i := 0 to Words.Count-2 do
                Blocks.AddSafely(TTextPadBlock.Create(Obj, Self, Words[i],
                  Words[i+1] - Words[i], CharAttrs));
            end;
          finally
            Assert( ScriptStringFree(Ctx) = S_OK );
          end;
        end;
      end
      else if Obj is TGraphicPadObject then
        Blocks.AddSafely(TGraphicPadBlock.Create(Obj, Self))
      else if Obj is TLineFeedPadObject then
        Blocks.AddSafely(TLineFeedPadBlock.Create(Obj, Self));
      Inc(CurObj);
    end;
  end;

begin
  Assert( not FLayingOut );

  FLayingOut := TRUE;
  try
    RightMargin := Width;
    if FBorder then
      Dec(RightMargin, 2 * BORDER_WIDTH);
    Dec(RightMargin, FMargin);

    if FLines <> nil then
    begin
      FLines.Clear;
      if Parent <> nil then
      begin
        Canvas.Font.Assign(Font);
        CurObj := 0;
        CurChar := 0;
        CurLine := nil;
        y := FMargin;
        Done := FALSE;
        Words := TIntegerList.Create;
        try
          Blocks := TPadBlockList.Create;
          try
            repeat
              if Blocks.Count = 0 then
                FetchBlocks;
              if Blocks.Count > 0 then
              begin
                if CurLine = nil then
                begin
                  CurLine := TPadLine.Create;
                  try
                    CurLine.FIndex := FLines.Count;
                    CurLine.FTop := y;
                    CurLine.FStartChar := CurChar;
                    FLines.Add(CurLine);
                  except
                    CurLine.Free;
                    raise;
                  end;
                  x := FMargin;
                end;
                Block := Blocks.First;
                if not (Block is TLineFeedPadBlock) and
                  (x + Block.GetRequiredWidth > RightMargin) and
                  (CurLine.BlockCount > 0) then
                  FinishLine
                else
                begin
                  Block.FPosition.x := x;
                  Block.FStartChar := CurChar;
                  Inc(CurChar, Block.GetCharCount);
                  Inc(CurLine.FCharCount, Block.GetCharCount);
                  Inc(x, Block.GetDesiredWidth);
                  CurLine.FHeight := Max(CurLine.FHeight, Block.GetHeight);
                  CurLine.FBlocks.Add(Block);
                  Block.FLine := CurLine;
                  Blocks.Extract(Block);
                  if Block is TLineFeedPadBlock then
                    FinishLine;
                end;
              end
              else
                Done := TRUE;
            until Done;
            FinishLine;
          finally
            Blocks.Free;
          end;
        finally
          Words.Free;
        end;

        if FLines.Count > 0 then
          FRawHeight := FLines.Last.FTop + FLines.Last.FHeight + FMargin
        else
          FRawHeight := 2*FMargin;
      end;
    end;
  finally
    FLayingOut := FALSE;
  end;
end;

procedure TPadWidget.MouseDown(Button: TMouseButton; Shift: TShiftState; X,
  Y: Integer);
var
  Block: TPadBlock;
  Listener: IMouseListener;
begin
  inherited;
  if not Focused and CanFocus then
    TrySetFocus(Self);

  if Button = mbLeft then
  begin
    if Focused then
    begin
      FMouseDownPos := Point(x, y);
      FMouseDown := TRUE;
    end
    else
      FMouseDown := FALSE;

    if ssDouble in Shift then
    begin
      if CanSelect then
      begin
        Block := CharPosToBlock(FCaretCharPos);
        if Block <> nil then
        begin
          SelStart := Block.FStartChar;
          SelLength := Block.GetCharCount;
          CaretCharPos := SelStart + SelLength;
        end;
      end;
    end
    else
      MoveCaretXY(ssShift in Shift, Point(x, y));

    if CaretEnabled and Types.PtInRect(ClientRect, Point(x, y)) then
      StartTimer;
  end;

  for Listener in FMouseListeners do
    Listener.NotifyMouseDown(Self, Button, Shift, X, Y);
end;

procedure TPadWidget.MoveCaretXY(Select: Boolean; const p: TPoint);
var
  Line: TPadLine;
  Position: TPadPosition;
  mx: Integer;
begin
  LayoutNeeded;
  Line := YToLineEx(p.y, Position);
  if (Position = ppAfter) and (FLines.Count > 0) then
  begin
    if HasSpecialEof then
      Navigate(Select, CharCount)
    else
    begin
      Line := FLines.Last;
      Position := ppLine;
    end;
  end;
  if (Position = ppBefore) and (FLines.Count > 0) then
  begin
    Line := FLines.First;
    Position := ppLine;
  end;
  if Position = ppLine then
  begin
    mx := Max(p.x, FMargin);
    Navigate(Select, ScreenPosToCharPos(MakeScreenPos(mx, Line.FIndex)), mx);
  end;
end;

procedure TPadWidget.MouseMove(Shift: TShiftState; X, Y: Integer);
var
  ThresholdReached: Boolean;
  Listener: IMouseListener;
begin
  inherited;
  if GetAsyncKeyState(VK_LBUTTON) >= 0 then
    FMouseDown := FALSE;

  if CaretEnabled and Focused and FMouseDown then
  begin
    if (FMouseDownPos.x = MaxInt) or (FMouseDownPos.y = MaxInt) then
      ThresholdReached := TRUE
    else
    begin
      ThresholdReached := (Abs(x - FMouseDownPos.x) > MOUSE_SELECT_THRESHOLD)
        or (Abs(y - FMouseDownPos.y) > MOUSE_SELECT_THRESHOLD);
      if ThresholdReached then
        FMouseDownPos := Point(MaxInt, MaxInt);
    end;

    if ThresholdReached then
    begin
      MoveCaretXY(TRUE, Point(x, y));
      StartTimer;
    end;
  end;

  for Listener in FMouseListeners do
    Listener.NotifyMouseMove(Self, Shift, X, Y);
end;

procedure TPadWidget.Paint;
var
  i, BlockSelStart, BlockSelEnd, BlockSelLength: Integer;
  Line: TPadLine;
  Block: TPadBlock;
  y, FirstLine, LastLine: Integer;
  ClipRect: TRect;
  ClipWidth, ClipHeight: Integer;
  Bmp: TBitmap;
begin
  inherited;
  LayoutNeeded;

  ClipRect := Canvas.ClipRect;
  ClipWidth := ClipRect.Right - ClipRect.Left;
  ClipHeight := ClipRect.Bottom - ClipRect.Top;
  if (ClipWidth > 0) and (ClipHeight > 0) then
  begin
    Bmp := TBitmap.Create;
    try
      Bmp.Width := ClipWidth;
      Bmp.Height := ClipHeight;
      Bmp.Canvas.Brush.Color := Color;
      Bmp.Canvas.FillRect(Rect(0, 0, ClipWidth, ClipHeight));
      if FLines.Count > 0 then
      begin
        Bmp.Canvas.Font.Assign(Font);

        Line := YToLine(ClipRect.Top);
        if Line <> nil then
          FirstLine := Line.FIndex
        else
          FirstLine := 0;
        Line := YToLine(ClipRect.Bottom);
        if Line <> nil then
          LastLine := Line.FIndex
        else
          LastLine := FLines.Count-1;

        for i := FirstLine to LastLine do
        begin
          Line := FLines[i];
          for Block in Line.FBlocks do
          begin
            y := Block.FPosition.y;
            if IntersectSegments(FSelStart, FSelStart+FSelLength-1, Block.FStartChar, Block.FStartChar+Block.GetCharCount-1,
              BlockSelStart, BlockSelEnd) then
            begin
              BlockSelLength := BlockSelEnd-BlockSelStart+1;
              Dec(BlockSelStart, Block.FStartChar);
            end
            else
            begin
              BlockSelStart := 0;
              BlockSelLength := 0;
            end;
            Block.Draw(Bmp.Canvas, Point(Block.FPosition.x - ClipRect.Left, y - ClipRect.Top),
              BlockSelStart, BlockSelLength);
          end;
        end;
      end;

      Canvas.Draw(ClipRect.Left, ClipRect.Top, Bmp);
    finally
      Bmp.Free;
    end;
  end;
end;

procedure TPadWidget.Resize;
begin
  inherited;
  if not FLayingOut then
  begin
    if not FLayoutValid or (Width <> FLaidOutSize.cx) or (Height <> FLaidOutSize.cy) then
      InvalidateLayout;
    Invalidate;
    InvalidateCaret;
  end;
end;

procedure TPadWidget.SetMargin(Value: Integer);
begin
  if FMargin <> Value then
  begin
    Assert( Value >= 0 );
    FMargin := Value;

    InvalidateLayout;
    Invalidate;
    InvalidateCaret;
  end;
end;

procedure TPadWidget.SetParent(Parent: TWinControl);
begin
  if Parent <> Self.Parent then
  begin
    InvalidateLayout;
    inherited;
    if (Parent = nil) and (FLines <> nil) then
      FLines.Clear;
    InvalidateCaret;
    Invalidate;
  end;
end;

procedure TPadWidget.SetReadOnly(Value: Boolean);
begin
  if FReadOnly <> Value then
  begin
    FReadOnly := Value;

    InvalidateCaret;
    Invalidate;
    UpdateCursor;
  end;
end;

procedure TPadWidget.SetSpacing(Value: Integer);
begin
  if FSpacing <> Value then
  begin
    Assert( Value >= 0 );
    FSpacing := Value;

    InvalidateLayout;
    Invalidate;
    InvalidateCaret;
  end;
end;

function TPadWidget.GetAdjacentCharPos(CharPos: Integer; Next: Boolean): Integer;
var
  Block, NextBlock, PreviousBlock: TPadBlock;
  BlockCharPos, NewPos: Integer;
begin
  if FLines.Count = 0 then
    Result := 0
  else
  begin
    if CharPos = CharCount then
    begin
      Block := FLines.Last.FBlocks.Last;
      BlockCharPos := Block.GetCharCount;
    end
    else
    begin
      Block := CharPosToBlockPos(CharPos, BlockCharPos);
      Assert( Block <> nil );
    end;

    NewPos := Block.GetAdjacentCharPos(BlockCharPos, Next);
    if NewPos = -1 then
    begin
      if Next then
      begin
        NextBlock := GetNextBlock(Block);
        if NextBlock = nil then
          Result := GetCharCount
        else
          Result := NextBlock.FStartChar;
      end
      else
      begin
        PreviousBlock := GetPreviousBlock(Block);
        if PreviousBlock = nil then
          Result := 0
        else
        begin
          NewPos := PreviousBlock.GetAdjacentCharPos(PreviousBlock.GetCharCount, FALSE);
          if NewPos = -1 then
            NewPos := 0;
          Result := PreviousBlock.FStartChar + NewPos;
        end;
      end;
    end
    else
      Result := CharPos + (NewPos - BlockCharPos);
  end;
end;

procedure TPadWidget.SelectAllClick(Sender: TObject);
begin
  SelectAll;
end;

procedure TPadWidget.WMKillFocus(var Message: TWMKillFocus);
begin
  inherited;
  if ComponentState * [csDestroying, csLoading] = [] then
  begin
    DestroyCaret;
    Invalidate;
  end;
end;

procedure TPadWidget.WMSetFocus(var Message: TWMSetFocus);
begin
  inherited;
  Invalidate;
  InvalidateCaret;
end;

procedure TPadWidget.UTF8KeyPress(var UTF8Key: TUTF8Char);
var
  Input: UnicodeString;
  Fragment: TPad;
begin
  inherited;
  Input := UTF8Decode(UTF8Key);
  if not FReadOnly and (Input <> '') and (Input[1] >= ' ') and (Input[1] <> #$7f) then
  begin
    FModel.BeginModify;
    try
      DeleteSelection;

      Fragment := TPad.Create;
      try
        Fragment.AddText(Input);
        InsertFragmentAtCaretPos(Fragment);
      finally
        Fragment.Free;
      end;
    finally
      FModel.EndModify;
    end;
  end;
end;

function TPadWidget.GetLineCount: Integer;
begin
  if FLines <> nil then
    Result := FLines.Count
  else
    Result := 0;
end;

function TPadWidget.CharPosToBlockPos(CharPos: Integer; out BlockCharPos: Integer): TPadBlock;
var
  Line: TPadLine;
  p: Integer;
begin
  LayoutNeeded;
  Line := CharPosToLine(CharPos);
  if Line <> nil then
  begin
    p := Line.FStartChar;
    for Result in Line.FBlocks do
    begin
      if p + Result.GetCharCount > CharPos then
      begin
        BlockCharPos := CharPos - p;
        Exit;
      end
      else
        Inc(p, Result.GetCharCount);
    end;
  end;
  Result := nil;
  BlockCharPos := -1;
end;

function TPadWidget.CharPosToBlock(CharPos: Integer): TPadBlock;
var
  DummyBlockCharPos: Integer;
begin
  Result := CharPosToBlockPos(CharPos, DummyBlockCharPos);
end;

function TPadWidget.CharPosToLine(CharPos: Integer): TPadLine;
begin
  LayoutNeeded;
  for Result in FLines do
    if (CharPos >= Result.FStartChar) and (CharPos < Result.FStartChar + Result.FCharCount) then
      Exit;
  Result := nil;
end;

procedure TPadWidget.WMEraseBkgnd(var Message: TWMEraseBkgnd);
begin
  Message.Result := 1;
end;

procedure TPadWidget.CalculatePreferredSize(var PreferredWidth,
  PreferredHeight: Integer; WithThemeSpace: Boolean);
begin
  PreferredHeight := ContentHeight;
  if FLines.Count = 0 then
    Inc(PreferredHeight, Canvas.TextHeight('|'));
  if FBorder then
    Inc(PreferredHeight, 2 * BORDER_WIDTH);
end;

procedure TPadWidget.DoContextPopup(MousePos: TPoint; var Handled: Boolean);
begin
  if CaretEnabled then
  begin
    FPopupMenu.Items.Clear;
    FPopupMenuImages.Clear;

    AddPopupMenuItem(SCut, 'PadWidget/cut.png', ShortCut(VK_X, [ssCtrl]), CutClick)
      .Enabled := not ReadOnly and HasSelection;
    AddPopupMenuItem(SCopy, 'PadWidget/copy.png', ShortCut(VK_C, [ssCtrl]), CopyClick)
      .Enabled := HasSelection;
    AddPopupMenuItem(SPaste, 'PadWidget/paste.png', ShortCut(VK_V, [ssCtrl]), PasteClick)
      .Enabled := not ReadOnly and (GetAvailableClipboardFormats <> []);
    AddPopupMenuItem(SDelete, 'PadWidget/delete.png', ShortCut(VK_DELETE, []), DeleteClick)
      .Enabled := not ReadOnly and HasSelection;
    AddPopupMenuItem(SSelectAll, '', ShortCut(VK_A, [ssCtrl]), SelectAllClick);
    AddPopupMenuItem('-', '', 0, nil);
    AddPopupMenuItem(SOpenImage, 'PadWidget/openImage.png', 0, OpenImageClick)
      .Enabled := not ReadOnly;
    AddPopupMenuItem(SSaveImage, 'PadWidget/saveImage.png', 0, SaveImageClick)
      .Enabled := SelectedGraphicBlock <> nil;

    FPopupMenu.PopUp;
    Handled := TRUE;
  end
  else
    inherited;
end;

function TPadWidget.AddPopupMenuItem(const Caption, ImageResourceName: String;
  ShortCut: TShortCut; OnClick: TNotifyEvent): TMenuItem;
begin
  Result := TMenuItem.Create(FPopupMenu);
  Result.Caption := Caption;
  if ImageResourceName <> '' then
    Result.ImageIndex := AddPngResourceToImageList(ImageResourceName, FPopupMenuImages);
  Result.ShortCut := ShortCut;
  Result.OnClick := OnClick;
  FPopupMenu.Items.Add(Result);
end;

procedure TPadWidget.CutClick(Sender: TObject);
begin
  CutToClipboard;
end;

procedure TPadWidget.CopyClick(Sender: TObject);
begin
  CopyToClipboard;
end;

procedure TPadWidget.PasteClick(Sender: TObject);
begin
  Paste(TRUE);
end;

procedure TPadWidget.DeleteClick(Sender: TObject);
begin
  DeleteSelection;
end;

function FindGraphicClassByExtension(const Extension: String): TGraphicClass;
begin
  if SameText(Extension, 'png') then
    Result := TPortableNetworkGraphic
  else if SameText(Extension, 'jpg') or SameText(Extension, 'jpeg') then
    Result := TJPEGImage
  else
    raise Exception.CreateFmt(SUnknownExtension, [Extension]);
end;

function LoadGraphicObject(const FileName: String): TGraphicPadObject;
var
  Bmp: TBitmap;
  Png: TPortableNetworkGraphic;
  Ext, ImageFormat: String;
  fs: TUnicodeFileStream;
  GraphicClass: TGraphicClass;
  Graphic: TGraphic;
begin
  try
    Result := TGraphicPadObject.Create;
    try
      Ext := ExcludeLeadingDot(ExtractFileExt(FileName));
      if SameText(Ext, 'bmp') then
      begin
        Bmp := TBitmap.Create;
        try
          fs := TUnicodeFileStream.OpenForRead(FileName);
          try
            Bmp.LoadFromStream(fs);
          finally
            fs.Free;
          end;

          Png := BmpToPng(Bmp);
          try
            CopyGraphicToGraphicObject(Png, Result);
          finally
            Png.Free;
          end;
        finally
          Bmp.Free;
        end;
      end
      else
      begin
        fs := TUnicodeFileStream.OpenForRead(FileName);
        try
          GraphicClass := FindGraphicClassByExtension(Ext);
          ImageFormat := FindImageFormat(GraphicClass);

          { Check that the file contains valid data. }
          Graphic := GraphicClass.Create;
          try
            Graphic.LoadFromStream(fs);
            Bmp := TBitmap.Create;
            try
              Bmp.Assign(Graphic);
            finally
              Bmp.Free;
            end;
          finally
            Graphic.Free;
          end;

          fs.Seek(0, soFromBeginning);
          Result.ImageData := ReadStreamTail(fs);
          Result.ImageFormat := ImageFormat;
        finally
          fs.Free;
        end;
      end;
    except
      Result.Free;
      raise;
    end;
  except
    on E: EFOpenError do
      raise;
    on E: Exception do
      raise Exception.CreateFmt(SFileLoadingError, [FileName, E.Message]);
  end;
end;

procedure TPadWidget.OpenImageClick(Sender: TObject);
var
  d: TOpenDialog;
  Fragment: TPad;
  FileName: String;
begin
  d := TOpenDialog.Create(nil);
  try
    d.Options := d.Options + [ofHideReadOnly, ofNoChangeDir, ofAllowMultiSelect];
    d.Filter := SOpenImageFilter;
    d.Title := SInsertImage;

    if d.Execute then
    begin
      Fragment := TPad.Create;
      try
        for FileName in d.Files do
          Fragment.AddObject(LoadGraphicObject(FileName));
        InsertFragmentAtCaretPos(Fragment);
      finally
        Fragment.Free;
      end;
    end;
  finally
    d.Free;
  end;
end;

procedure TPadWidget.SaveImageClick(Sender: TObject);
var
  Block: TGraphicPadBlock;
  d: TSaveDialog;
  OutputFile: TOutputFile;
  ImageData: String;
begin
  Block := SelectedGraphicBlock;
  if Block <> nil then
  begin
    ImageData := Block.Source.ImageData;
    d := TSaveDialog.Create(nil);
    try
      d.Options := d.Options + [ofHideReadOnly, ofNoChangeDir, ofOverwritePrompt];
      d.Filter := Format(SSaveImageFilter, [UpperCase(Block.Extension), Block.Extension]);
      d.DefaultExt := Block.Extension;
      d.Title := SSaveImageDialogTitle;

      if d.Execute then
      begin
        OutputFile := TOutputFile.Create(d.FileName);
        try
          WriteStreamString(OutputFile.Stream, ImageData);
          OutputFile.Commit;
        finally
          OutputFile.Free;
        end;
      end;
    finally
      d.Free;
    end;
  end;
end;

class function TPadWidget.MakeScreenPos(x, Line: Integer): TScreenPos;
begin
  Result.x := x;
  Result.Line := Line;
end;

function TPadWidget.YToLine(y: Integer): TPadLine;
var
  DummyPosition: TPadPosition;
begin
  Result := YToLineEx(y, DummyPosition);
end;

function TPadWidget.YToLineEx(y: Integer; out Position: TPadPosition): TPadLine;
var
  Line: TPadLine;
begin
  LayoutNeeded;
  Result := nil;
  Position := ppBefore;
  if y >= FMargin then
  begin
    if y >= FRawHeight - FMargin then
      Position := ppAfter
    else
    begin
      for Line in FLines do
      begin
        if y < Line.FTop + Line.FHeight then
        begin
          Result := Line;
          Position := ppLine;
          Break;
        end;
      end;
    end;
  end;
end;

function TPadWidget.ScreenPosToCharPos(ScreenPos: TScreenPos): Integer;
var
  Line: TPadLine;
  Block: TPadBlock;
begin
  LayoutNeeded;
  if FLines.Count = 0 then
    Result := 0
  else if (ScreenPos.Line >= FLines.Count) and HasSpecialEof then
    Result := CharCount
  else
  begin
    ScreenPos.Line := Min(Max(ScreenPos.Line, 0), FLines.Count-1);
    Line := FLines[ScreenPos.Line];
    Block := LineXToBlock(Line, ScreenPos.x);
    if Block <> nil then
      Result := Block.FStartChar + Block.XToCharPos(ScreenPos.x - Block.FPosition.x)
    else
      if (ScreenPos.Line = FLines.Count-1) and not HasSpecialEof then
        Result := CharCount
      else
        Result := FLines[ScreenPos.Line].FStartChar + FLines[ScreenPos.Line].FCharCount - 1;
  end;
end;

function TPadWidget.CharPosToScreenPos(CharPos: Integer): TScreenPos;
var
  d: TPositionDescriptor;
begin
  d := DescribePosition(CharPos);
  Result := MakeScreenPos(d.Origin.x, d.LineIndex);
end;

procedure TPadWidget.SetCaretCharPos(Value: Integer);
begin
  MoveCaret(Value, -1);
end;

procedure TPadWidget.MoveCaret(CharPos: Integer; XPos: Integer = -1);
begin
  LayoutNeeded;
  CharPos := Min(Max(CharPos, 0), CharCount);
  if FCaretCharPos <> CharPos then
  begin
    FCaretCharPos := CharPos;
    InvalidateCaret;
  end;
  if XPos < 0 then
    XPos := CharPosToScreenPos(CharPos).x;
  FCaretX := XPos;
end;

procedure TPadWidget.OffsetCaretLine(Offset: Integer);
var
  p: TScreenPos;
begin
  LayoutNeeded;
  p := GetCaretScreenPos;
  Inc(p.Line, Offset);
  Navigate(ShiftDown, ScreenPosToCharPos(p), p.x);
end;

function TPadWidget.GetCaretScreenPos: TScreenPos;
var
  p: TScreenPos;
begin
  LayoutNeeded;
  p := CharPosToScreenPos(FCaretCharPos);
  if ScreenPosToCharPos(MakeScreenPos(FCaretX, p.Line)) = FCaretCharPos then
    Result := MakeScreenPos(FCaretX, p.Line)
  else
    Result := p;
end;

procedure TPadWidget.LayoutNeeded;
var
  p: Integer;
begin
  if not FLayoutValid then
  begin
    LayOut;
    FLaidOutSize := Size(Width, Height);
    FLayoutValid := TRUE;

    p := Min(FCaretCharPos, CharCount);
    if p < CharCount then
      p := GetAdjacentCharPos(GetAdjacentCharPos(p, TRUE), FALSE);
    FCaretCharPos := p;
  end;
end;

procedure TPadWidget.InvalidateLayout;
begin
  FLayoutValid := FALSE;
  InvalidatePreferredSize;
end;

procedure TPadWidget.MoveCaretByPage(Down: Boolean);
var
  Scrollable: TScrollingWinControl;
  h, Line, LinesPerPage: Integer;
begin
  Scrollable := TScrollingWinControl(GetAncestorOfType(Self, TScrollBox));
  if Scrollable <> nil then
  begin
    LayoutNeeded;

    h := Canvas.TextHeight('|') + FSpacing;
    if h > 0 then
      LinesPerPage := Max(Scrollable.ClientHeight div h, 1)
    else
      LinesPerPage := 1;

    Line := CharPosToScreenPos(FCaretCharPos).Line;
    if Down then
      Inc(Line, LinesPerPage)
    else
      Dec(Line, LinesPerPage);

    Navigate(ShiftDown, ScreenPosToCharPos(MakeScreenPos(FCaretX, Line)), FCaretX);
  end;
end;

function TPadWidget.LineXToBlock(Line: TPadLine; x: Integer): TPadBlock;
{ Returns nil if the block was not found. }
var
  p: Integer;
  Block: TPadBlock;
begin
  Result := nil;
  if x >= FMargin then
  begin
    p := FMargin;
    for Block in Line.FBlocks do
    begin
      Inc(p, Block.GetDesiredWidth);
      if p > x then
      begin
        Result := Block;
        Break;
      end;
    end;
  end;
end;

function TPadWidget.GetCharCount: Integer;
begin
  LayoutNeeded;
  if FLines.Count > 0 then
    Result := FLines.Last.FStartChar + FLines.Last.FCharCount
  else
    Result := 0;
end;

function TPadWidget.GetCaretLine: TPadLine;
var
  p: TScreenPos;
begin
  p := GetCaretScreenPos;
  if (p.Line >= 0) and (p.Line < FLines.Count) then
    Result := FLines[p.Line]
  else
    Result := nil;
end;

function TPadWidget.GetContentHeight: Integer;
begin
  LayoutNeeded;
  Result := InternalGetContentHeight;
end;

function TPadWidget.InternalGetContentHeight: Integer;
begin
  Result := FRawHeight;
  if (FLines.Count > 0) and (FLines.Last.FBlocks.Last is TLineFeedPadBlock) then
    Inc(Result, Canvas.TextHeight('|') + FSpacing);
end;

procedure TPadWidget.InvalidateCaret;
begin
  if HandleAllocated then
  begin
    if Focused then
      DestroyCaret;
    if not FCaretUpdateQueued then
    begin
      PostMessage(Handle, WM_PAD_UPDATE_CARET, 0, 0);
      FCaretUpdateQueued := TRUE;
    end;
  end;
end;

function TPadWidget.DescribePosition(CharPos: Integer): TPositionDescriptor;
var
  LastLine: TPadLine;
  Block: TPadBlock;
  BlockCharPos: Integer;
begin
  LayoutNeeded;
  CharPos := Min(Max(CharPos, 0), CharCount);

  if CharPos = CharCount then
  begin
    if FLines.Count = 0 then
    begin
      Result.Origin := Point(FMargin, FMargin);
      Result.LineIndex := 0;
      Result.LineTop := Result.Origin.y;
      Result.Height := Canvas.TextHeight('|');
    end
    else
    begin
      LastLine := FLines.Last;
      if HasSpecialEof then
      begin
        Result.Origin := Point(FMargin, LastLine.FTop + LastLine.FHeight + FSpacing);
        Result.LineIndex := LineCount;
        Result.LineTop := Result.Origin.y;
        Result.Height := Canvas.TextHeight('|');
      end
      else
      begin
        Block := LastLine.FBlocks.Last;
        Result.Origin := Point(Block.FPosition.x + Block.GetDesiredWidth, Block.FPosition.y);
        Result.LineIndex := LineCount-1;
        Result.LineTop := Block.FLine.FTop;
        Result.Height := Block.GetHeight;
      end;
    end;
  end
  else
  begin
    Block := CharPosToBlockPos(CharPos, BlockCharPos);
    if Block = nil then { should not happen }
    begin
      Result.Origin := Point(0, 0);
      Result.LineIndex := 0;
      Result.LineTop := Result.Origin.y;
      Result.Height := 0;
    end
    else
    begin
      Result.Origin := Point(Block.CharPosToX(BlockCharPos) + Block.FPosition.x, Block.FPosition.y);
      Result.LineIndex := Block.FLine.FIndex;
      Result.LineTop := Block.FLine.FTop;
      Result.Height := Block.GetHeight;
    end;
  end;
end;

function TPadWidget.ImeActive: Boolean;
var
  Ctx: HIMC;
begin
  Ctx := ImmGetContext(Handle);
  try
    Result := ImmGetCompositionString(Ctx, GCS_COMPSTR, nil, 0) > 0;
  finally
    ImmReleaseContext(Handle, Ctx);
  end;
end;

procedure TPadWidget.WMUpdateCaret(var Message: TMessage);
var
  d: TPositionDescriptor;
begin
  LayoutNeeded;
  if Focused then
  begin
    if CaretEnabled and not ImeActive then
    begin
      d := DescribePosition(FCaretCharPos);
      if CreateCaret(Handle, 0, 2, d.Height) then
      begin
        SetCaretPos(d.Origin.x-1, d.Origin.y);
        ShowCaret(Handle);
        if not LeftButtonDown then
          ScrollControlPartIntoView(Self, d.Origin.y, d.Height);
      end;
    end
    else
      DestroyCaret;
  end;
  FCaretUpdateQueued := FALSE;
end;

procedure TPadWidget.WMImeStartComposition(var Message: TMessage);
var
  Ctx: HIMC;
  cf: COMPOSITIONFORM;
begin
  Ctx := ImmGetContext(Handle);
  try
    cf.dwStyle := CFS_POINT;
    cf.ptCurrentPos := DescribePosition(FCaretCharPos).Origin;
    ImmSetCompositionWindow(Ctx, @cf);
  finally
    ImmReleaseContext(Handle, Ctx);
  end;
  InvalidateCaret;
end;

procedure TPadWidget.WMImeEndComposition(var Message: TMessage);
begin
  InvalidateCaret;
end;

procedure TPadWidget.SetShowCaretInReadOnly(Value: Boolean);
begin
  if FShowCaretInReadOnly <> Value then
  begin
    FShowCaretInReadOnly := Value;

    InvalidateCaret;
    Invalidate;
  end;
end;

procedure TPadWidget.InsertObjectAtCaretPos(Obj: TPadObject);
var
  Pad: TPad;
  TmpObj: TPadObject;
begin
  try
    Pad := TPad.Create;
    try
      TmpObj := Obj;
      Obj := nil;
      Pad.AddObject(TmpObj);
      InsertFragmentAtCaretPos(Pad);
    finally
      Pad.Free;
    end;
  except
    Obj.Free;
    raise;
  end;
end;

procedure TPadWidget.CreateParams(var Params: TCreateParams);
begin
  inherited;
  if FBorder then
    Params.Style := Params.Style or WS_BORDER;
end;

procedure TPadWidget.SetBorder(Value: Boolean);
begin
  if FBorder <> Value then
  begin
    FBorder := Value;
    RecreateWnd(Self);
  end;
end;

procedure TPadWidget.UpdateCursor;
begin
  if FReadOnly then
    Cursor := crDefault
  else
    Cursor := crIBeam;
end;

procedure TPadWidget.SetSelStart(Value: Integer);
begin
  if FSelStart <> Value then
  begin
    FSelStart := Max(Min(Value, CharCount-1), 0);
    FSelLength := 0;
    Invalidate;
  end;
end;

procedure TPadWidget.SetSelLength(Value: Integer);
begin
  if FSelLength <> Value then
  begin
    FSelLength := Max(Min(Value, CharCount-FSelStart), 0);
    Invalidate;
  end;
end;

procedure TPadWidget.SelectNothing;
begin
  SelLength := 0;
end;

procedure TPadWidget.SelectAll;
begin
  SelStart := 0;
  SelLength := CharCount;
end;

procedure TPadWidget.CreateHandle;
begin
  inherited;
  FCaretUpdateQueued := FALSE;
  InvalidateCaret;
end;

function TPadWidget.CanSelect: Boolean;
{ Must return FALSE if CaretEnabled returns FALSE. }
begin
  Result := CaretEnabled;
end;

procedure TPadWidget.Navigate(Select: Boolean; CharPos: Integer; XPos: Integer = -1);
var
  TmpSelStart, TmpSelEnd: Integer;
begin
  if CaretEnabled then
  begin
    CharPos := Min(Max(CharPos, 0), CharCount);
    if CanSelect and Select then
    begin
      if CharPos <> FCaretCharPos then
      begin
        if FSelLength = 0 then
        begin
          SelStart := Min(CharPos, FCaretCharPos);
          SelLength := Abs(CharPos - FCaretCharPos);
        end
        else
        begin
          TmpSelStart := SelStart;
          TmpSelEnd := SelStart + SelLength;

          if TmpSelStart = FCaretCharPos then
            TmpSelStart := CharPos
          else if TmpSelEnd = FCaretCharPos then
            TmpSelEnd := CharPos
          else
          begin
            TmpSelStart := FCaretCharPos;
            TmpSelEnd := CharPos;
          end;

          SelStart := Min(TmpSelStart, TmpSelEnd);
          SelLength := Abs(TmpSelStart - TmpSelEnd);
        end;
      end;
    end
    else
      SelectNothing;
    MoveCaret(CharPos, XPos);
  end;
end;

procedure TPadWidget.ModelChange(Sender: TObject);
begin
  InvalidateLayout;
  Invalidate;
  InvalidateCaret;
  FSelStart := 0;
  FSelLength := 0;
end;

procedure TPadWidget.ModelEndModify(Sender: TObject);
begin
  AdjustSize;
end;

function TPadWidget.CaretEnabled: Boolean;
begin
  Result := not FReadOnly or FShowCaretInReadOnly;
end;

procedure TPadWidget.TimerTick;
begin
  if Focused and FMouseDown then
    DragScrollVertically(Self)
  else
  begin
    StopTimer;
    FMouseDown := FALSE;
  end;
end;

procedure TPadWidget.GetSpacingsForLine(LineIndex: Integer; out TopSpacing,
  BottomSpacing: Integer);
begin
  if LineIndex > 0 then
    TopSpacing := FSpacing div 2
  else
    TopSpacing := 0;

  if LineIndex < FLines.Count-1 then
    BottomSpacing := (FSpacing + 1) div 2
  else
    BottomSpacing := 0;
end;

procedure TPadWidget.StartTimer;
begin
  StopTimer;
  if HandleAllocated then
    SetTimer(Handle, 1, 100, nil);
end;

procedure TPadWidget.StopTimer;
begin
  if HandleAllocated then
    KillTimer(Handle, 1);
end;

procedure TPadWidget.WMTimer(var Message: TWMTimer);
begin
  inherited;
  TimerTick;
end;

function TPadWidget.GetPreviousBlock(Block: TPadBlock): TPadBlock;
var
  k: Integer;
begin
  k := Block.FLine.FBlocks.IndexOf(Block);
  if k > 0 then
    Result := Block.FLine.FBlocks[k-1]
  else if Block.FLine.FIndex > 0 then
    Result := FLines[Block.FLine.FIndex-1].FBlocks.Last
  else
    Result := nil;
end;

function TPadWidget.GetNextBlock(Block: TPadBlock): TPadBlock;
var
  k: Integer;
begin
  k := Block.FLine.FBlocks.IndexOf(Block);
  if k < Block.FLine.FBlocks.Count-1 then
    Result := Block.FLine.FBlocks[k+1]
  else if Block.FLine.FIndex < FLines.Count-1 then
    Result := FLines[Block.FLine.FIndex+1].FBlocks.First
  else
    Result := nil;
end;

function TPadWidget.HasSpecialEof: Boolean;
begin
  LayoutNeeded;
  Result := (FLines.Count > 0) and (FLines.Last.FBlocks.Last is TLineFeedPadBlock);
end;

procedure TPadWidget.DeleteFragment(StartChar, Len: Integer);
var
  StartBlock, EndBlock: TPadBlock;
  StartBlockPos, EndBlockPos, i: Integer;
  StartObjIndex, EndObjIndex: Integer;
  TextObj: TTextPadObject;
begin
  LayoutNeeded;
  StartChar := Max(StartChar, 0);
  Len := Min(Max(Len, 0), CharCount - StartChar);
  if Len > 0 then
  begin
    StartBlock := CharPosToBlockPos(StartChar, StartBlockPos);
    EndBlock := CharPosToBlockPos(StartChar + Len - 1, EndBlockPos);
    if StartBlock.FSource = EndBlock.FSource then
    begin
      if StartBlock.FSource is TTextPadObject then
      begin
        TextObj := TTextPadObject(StartBlock.FSource);
        Inc(StartBlockPos, (StartBlock as TTextPadBlock).FStartPos);
        Inc(EndBlockPos, (EndBlock as TTextPadBlock).FStartPos);
        if (StartBlockPos = 1) and (EndBlockPos = Length(TextObj.Text)) then
          FModel.RemoveObjectAndJoinText(TextObj)
        else
          TextObj.Text := Copy(TextObj.Text, 1, StartBlockPos-1) +
            Copy(TextObj.Text, EndBlockPos+1, Length(TextObj.Text) - EndBlockPos);
      end
      else
        FModel.RemoveObjectAndJoinText(StartBlock.FSource);
    end
    else
    begin
      FModel.BeginModify;
      try
        StartObjIndex := StartBlock.FSource.Index;
        EndObjIndex := EndBlock.FSource.Index;
        for i := EndObjIndex-1 downto StartObjIndex+1 do
          FModel.DeleteObject(i);

        if StartBlock.FSource is TTextPadObject then
        begin
          TextObj := TTextPadObject(StartBlock.FSource);
          Inc(StartBlockPos, (StartBlock as TTextPadBlock).FStartPos);
          if StartBlockPos = 1 then
            FModel.RemoveObject(TextObj)
          else
            TextObj.Text := Copy(TextObj.Text, 1, StartBlockPos-1);
        end
        else
          FModel.RemoveObject(StartBlock.FSource);

        if EndBlock.FSource is TTextPadObject then
        begin
          TextObj := TTextPadObject(EndBlock.FSource);
          Inc(EndBlockPos, (EndBlock as TTextPadBlock).FStartPos);
          if EndBlockPos = Length(TextObj.Text) then
            FModel.RemoveObject(TextObj)
          else
            TextObj.Text := Copy(TextObj.Text, EndBlockPos+1,
              Length(TextObj.Text) - EndBlockPos);
        end
        else
          FModel.RemoveObject(EndBlock.FSource);

        FModel.JoinTextObjects(StartObjIndex);
        FModel.JoinTextObjects(StartObjIndex-1);
      finally
        FModel.EndModify;
      end;
    end;

    if Assigned(FOnDelete) then
      FOnDelete(Self, StartChar, Len);
  end;
end;

procedure TPadWidget.DeleteSelection;
begin
  if FSelLength > 0 then
  begin
    CaretCharPos := FSelStart;
    DeleteFragment(FSelStart, FSelLength);
  end;
end;

function TPadWidget.GetHasSelection: Boolean;
begin
  Result := SelLength > 0;
end;

procedure TPadWidget.GetFragment(StartChar, Len: Integer; Pad: TPad);
var
  StartBlock, EndBlock: TPadBlock;
  StartBlockPos, EndBlockPos, i: Integer;
  StartObjIndex, EndObjIndex: Integer;
  TextObj: TTextPadObject;
begin
  LayoutNeeded;
  Pad.BeginModify;
  try
    Pad.Clear;
    StartChar := Max(StartChar, 0);
    Len := Min(Max(Len, 0), CharCount - StartChar);
    if Len > 0 then
    begin
      StartBlock := CharPosToBlockPos(StartChar, StartBlockPos);
      EndBlock := CharPosToBlockPos(StartChar + Len - 1, EndBlockPos);
      StartObjIndex := StartBlock.FSource.Index;
      EndObjIndex := EndBlock.FSource.Index;
      for i := StartObjIndex to EndObjIndex do
        Pad.AddObject(FModel.Objects[i].Clone);
      if StartBlock.FSource is TTextPadObject then
      begin
        Inc(StartBlockPos, (StartBlock as TTextPadBlock).FStartPos);
        if StartBlockPos > 1 then
        begin
          TextObj := Pad.Objects[0] as TTextPadObject;
          TextObj.Text := Copy(TextObj.Text, StartBlockPos, Length(TextObj.Text) - StartBlockPos + 1);
        end;
      end;
      if EndBlock.FSource is TTextPadObject then
      begin
        Inc(EndBlockPos, (EndBlock as TTextPadBlock).FStartPos);
        if EndBlockPos < Length(TTextPadObject(EndBlock.FSource).Text) then
        begin
          TextObj := Pad.Objects[Pad.ObjectCount-1] as TTextPadObject;
          TextObj.Text := Copy(TextObj.Text, 1, Length(TextObj.Text)
            - (Length(TTextPadObject(EndBlock.FSource).Text) - EndBlockPos));
        end;
      end;
    end;
  finally
    Pad.EndModify;
  end;
end;

procedure TPadWidget.GetSelection(Pad: TPad);
begin
  GetFragment(FSelStart, FSelLength, Pad);
end;

procedure TPadWidget.InsertFragment(CharPos: Integer; Pad: TPad);
var
  b: Integer;
  BlockCharPos, i: Integer;
  Block: TPadBlock;
  s, Tail: UnicodeString;
  NewTextObj: TTextPadObject;
begin
  if not Pad.IsEmpty then
  begin
    LayoutNeeded;
    FModel.BeginModify;
    try
      CharPos := Min(Max(CharPos, 0), CharCount);
      if CharPos = CharCount then
        b := FModel.ObjectCount
      else
      begin
        Block := CharPosToBlockPos(CharPos, BlockCharPos);
        Assert( Block <> nil );
        b := Block.FSource.Index;
        if Block is TTextPadBlock then
        begin
          Inc(BlockCharPos, TTextPadBlock(Block).FStartPos);
          if BlockCharPos > 1 then
          begin
            s := TTextPadObject(Block.FSource).Text;
            Tail := Copy(s, BlockCharPos, Length(s) - BlockCharPos + 1);
            TTextPadObject(Block.FSource).Text := Copy(s, 1, BlockCharPos-1);
            Inc(b);
            NewTextObj := TTextPadObject.Create;
            try
              NewTextObj.Text := Tail;
              FModel.InsertObject(NewTextObj, b);
            except
              NewTextObj.Free;
              raise;
            end;
          end;
        end;
      end;
      for i := 0 to Pad.ObjectCount-1 do
        FModel.InsertObject(Pad.Objects[i].Clone, b + i);
      FModel.JoinTextObjects(b + Pad.ObjectCount - 1);
      FModel.JoinTextObjects(b-1);
    finally
      FModel.EndModify;
    end;

    if Assigned(FOnInsert) then
      FOnInsert(Self, CharPos, Pad);
  end;
end;

procedure TPadWidget.InsertFragmentAtCaretPos(Pad: TPad);
begin
  InsertFragment(FCaretCharPos, Pad);
  CaretCharPos := FCaretCharPos + Pad.GetCharCount;
end;

procedure TPadWidget.CopyToClipboard;
var
  Pad: TPad;
begin
  if FSelLength > 0 then
  begin
    Pad := TPad.Create;
    try
      GetSelection(Pad);
      PutPadToClipboard(Pad);
    finally
      Pad.Free;
    end;
  end;
end;

procedure TPadWidget.CutToClipboard;
begin
  CopyToClipboard;
  DeleteSelection;
end;

procedure TPadWidget.DestroyHandle;
begin
  StopTimer;
  inherited;
end;

procedure TPadWidget.PasteText;
var
  Pad: TPad;
begin
  if Clipboard.HasFormat(CF_UNICODETEXT) then
  begin
    Pad := TPad.Create;
    try
      Pad.SimpleText := UTF8Decode(Clipboard.AsText);
      InsertFragmentAtCaretPos(Pad);
    finally
      Pad.Free;
    end;
  end;
end;

procedure TPadWidget.PasteFragment;
var
  Pad: TPad;
  Stream: TMemoryStream;
begin
  Stream := TMemoryStream.Create;
  try
    if Clipboard.GetFormat(GetFragmentClipboardFormat, Stream) then
    begin
      Pad := TPad.Create;
      try
        Stream.Seek(0, soFromBeginning);
        Pad.LoadFromStream(Stream);
        InsertFragmentAtCaretPos(Pad);
      finally
        Pad.Free;
      end;
    end;
  finally
    Stream.Free;
  end;
end;

procedure TPadWidget.PasteBitmap;
var
  Stream: TMemoryStream;
  Bitmap: TBitmap;
  Png: TPortableNetworkGraphic;
  Obj: TGraphicPadObject;
begin
  Stream := TMemoryStream.Create;
  try
    Png := TPortableNetworkGraphic.Create;
    try
      if Clipboard.GetFormat(GetPngClipboardFormat, Stream) then
      begin
        Stream.Seek(0, soFromBeginning);
        Png.LoadFromStream(Stream);
      end
      else
      begin
        Stream.Size := 0;
        if Clipboard.GetFormat(CF_BITMAP, Stream) then
        begin
          Bitmap := TBitmap.Create;
          try
            Stream.Seek(0, soFromBeginning);
            Bitmap.LoadFromStream(Stream);
            Png.Assign(Bitmap);
          finally
            Bitmap.Free;
          end;
        end;
      end;

      if (Png.Width > 0) and (Png.Height > 0) then
      begin
        Obj := TGraphicPadObject.Create;
        try
          CopyGraphicToGraphicObject(Png, Obj);
          GrabSourceData(Obj);
        except
          FreeAndNil(Obj);
          raise;
        end;
        InsertObjectAtCaretPos(Obj);
      end;
    finally
      Png.Free;
    end;
  finally
    Stream.Free;
  end;
end;

function TPadWidget.GetAvailableClipboardFormats: TPadClipboardFormats;
begin
  Result := [];
  if Clipboard.HasFormat(GetFragmentClipboardFormat) then
    Include(Result, pcfFragment);
  if Clipboard.HasFormat(Windows.CF_BITMAP) or Clipboard.HasFormat(GetPngClipboardFormat) then
    Include(Result, pcfBitmap);
  if Clipboard.HasFormat(CF_UNICODETEXT) then
    Include(Result, pcfText);
end;

procedure TPadWidget.PasteFormat(Fmt: TPadClipboardFormat; ReplaceSelection: Boolean);
begin
  FModel.BeginModify;
  try
    if ReplaceSelection then
      DeleteSelection;
    case Fmt of
      pcfFragment: PasteFragment;
      pcfBitmap: PasteBitmap;
      pcfText: PasteText;
      else
        Assert( FALSE );
    end;
  finally
    FModel.EndModify;
  end;
end;

procedure TPadWidget.Paste(ReplaceSelection: Boolean);
var
  Fmt: TPadClipboardFormat;
begin
  if GetBestAvailableClipboardFormat(Fmt) then
    PasteFormat(Fmt, ReplaceSelection);
end;

function TPadWidget.GetBestAvailableClipboardFormat(out Fmt: TPadClipboardFormat): Boolean;
var
  Formats: TPadClipboardFormats;
begin
  Result := TRUE;
  Formats := GetAvailableClipboardFormats;
  if pcfFragment in Formats then
    Fmt := pcfFragment
  else if pcfText in Formats then
    Fmt := pcfText
  else if pcfBitmap in Formats then
    Fmt := pcfBitmap
  else
    Result := FALSE;
end;

function TPadWidget.SelectedGraphicBlock: TGraphicPadBlock;
var
  Block: TPadBlock;
begin
  if FSelLength = 1 then
  begin
    Block := CharPosToBlock(FSelStart);
    if Block is TGraphicPadBlock then
      Result := TGraphicPadBlock(Block)
    else
      Result := nil;
  end
  else
    Result := nil;
end;

procedure TPadWidget.MouseUp(Button: TMouseButton; Shift: TShiftState; X,
  Y: Integer);
var
  Listener: IMouseListener;
begin
  inherited;
  FMouseDown := FALSE;
  for Listener in FMouseListeners do
    Listener.NotifyMouseUp(Self, Button, Shift, X, Y);
end;

procedure TPadWidget.AddMouseListener(const Listener: IMouseListener);
begin
  FMouseListeners.Add(Listener);
end;

procedure TPadWidget.RemoveMouseListener(const Listener: IMouseListener);
begin
  FMouseListeners.Remove(Listener);
end;

{ TPadLine }

constructor TPadLine.Create;
begin
  inherited;
  FBlocks := TPadBlockList.Create;
end;

destructor TPadLine.Destroy;
begin
  FreeAndNil(FBlocks);
  inherited;
end;

function TPadLine.GetBlockCount: Integer;
begin
  if FBlocks <> nil then
    Result := FBlocks.Count
  else
    Result := 0;
end;

{ TLineFeedPadBlock }

procedure TLineFeedPadBlock.Draw(Canvas: TCanvas; const p: TPoint;
  SelStart, SelLength: Integer);
var
  dh, uh: Integer;
begin
  inherited;
  if (SelLength > 0) and FWidget.Focused then
  begin
    FWidget.GetSpacingsForLine(FLine.FIndex, uh, dh);
    Canvas.Brush.Color := FWidget.Color xor $ffffff;
    Canvas.FillRect(Rect(p.x, p.y - uh, p.x + 2, p.y + GetHeight + dh));
  end;
end;

function TLineFeedPadBlock.GetCharCount: Integer;
begin
  Result := 1;
end;

function TLineFeedPadBlock.GetHeight: Integer;
begin
  Result := FWidget.Canvas.TextHeight('|');
end;

function TLineFeedPadBlock.GetRequiredWidth: Integer;
begin
  Result := 0;
end;

{ TPadBlock }

function TPadBlock.CharPosToX(CharPos: Integer): Integer;
begin
  Result := 0;
end;

function TPadBlock.GetAdjacentCharPos(CharPos: Integer; Next: Boolean): Integer;
{ Returns -1 if adjacent position is not within this block. }
begin
  if Next then
    Inc(CharPos)
  else
    Dec(CharPos);

  if (CharPos >= 0) and (CharPos < GetCharCount) then
    Result := CharPos
  else
    Result := -1;
end;

constructor TPadBlock.Create(Source: TPadObject; Widget: TPadWidget);
begin
  inherited Create;
  FSource := Source;
  FWidget := Widget;
end;

procedure TPadBlock.Draw(Canvas: TCanvas; const p: TPoint; SelStart, SelLength: Integer);
begin
  { do nothing }
end;

function TPadBlock.GetDesiredWidth: Integer;
begin
  Result := GetRequiredWidth;
end;

function TPadBlock.XToCharPos(x: Integer): Integer;
begin
  Result := 0;
end;

{ TTextPadBlock }

function TTextPadBlock.CharPosToX(CharPos: Integer): Integer;
begin
  if CharPos > 0 then
    Result := FWidget.Canvas.TextWidth(UTF8Encode(Copy(Source.Text, FStartPos, CharPos)))
  else
    Result := 0;
end;

function TTextPadBlock.GetAdjacentCharPos(CharPos: Integer; Next: Boolean): Integer;
var
  Offset: Integer;
  InRange: Boolean;
begin
  if Next then
    Offset := 1
  else
    Offset := -1;

  repeat
    CharPos := CharPos + Offset;
    InRange := (CharPos >= 0) and (CharPos < FLen);
  until not InRange or (FCharAttrs[CharPos] and fCharStop <> 0);

  if InRange then
    Result := CharPos
  else
    Result := -1;
end;

constructor TTextPadBlock.Create(Source: TPadObject; Widget: TPadWidget; StartPos, Len: Integer;
  CharAttrs: PSCRIPT_LOGATTR);
begin
  Assert( Source is TTextPadObject );
  inherited Create(Source, Widget);
  FStartPos := StartPos;
  FLen := Len;
  SetLength(FCharAttrs, FLen);
  if FLen > 0 then
  begin
    Inc(CharAttrs, FStartPos-1);
    Move(CharAttrs^, FCharAttrs[0], FLen);
  end;
end;

procedure TTextPadBlock.Draw(Canvas: TCanvas; const p: TPoint; SelStart, SelLength: Integer);
var
  s1, s2, s3: String;
  w1, w2, y, uh, dh: Integer;
begin
  inherited;
  s1 := UTF8Encode(Copy(Source.Text, FStartPos, SelStart));
  if s1 <> '' then
    w1 := Canvas.TextWidth(s1)
  else
    w1 := 0;

  s2 := UTF8Encode(Copy(Source.Text, FStartPos + SelStart, SelLength));
  if s2 <> '' then
    w2 := Canvas.TextWidth(s2)
  else
    w2 := 0;

  s3 := UTF8Encode(Copy(Source.Text, FStartPos + SelStart + SelLength, FLen - SelStart - SelLength));

  if s2 <> '' then
  begin
    if FWidget.Focused then
    begin
      Canvas.Brush.Color := FWidget.Color xor $ffffff;
      Canvas.Font.Color := FWidget.Color;
    end
    else
    begin
      Canvas.Brush.Color := FWidget.Color;
      Canvas.Font.Color := FWidget.Font.Color;
    end;

    Canvas.TextOut(p.x + w1, p.y, s2);

    if FWidget.Focused then
    begin
      FWidget.GetSpacingsForLine(FLine.FIndex, uh, dh);
      if uh > 0 then
        Canvas.FillRect(Rect(p.x + w1, p.y - uh, p.x + w1 + w2, p.y));
      if dh > 0 then
      begin
        y := p.y + Canvas.TextHeight(s2);
        Canvas.FillRect(Rect(p.x + w1, y, p.x + w1 + w2, y + dh));
      end;
    end;
  end;

  Canvas.Brush.Color := FWidget.Color;
  Canvas.Font.Color := FWidget.Font.Color;
  if s1 <> '' then
    Canvas.TextOut(p.x, p.y, s1);
  if s3 <> '' then
    Canvas.TextOut(p.x + w1 + w2, p.y, s3);
end;

function TTextPadBlock.GetCharCount: Integer;
begin
  Result := FLen;
end;

function TTextPadBlock.GetDesiredWidth: Integer;
begin
  try
    Result := FWidget.Canvas.TextWidth(UTF8Encode(Text));
  except
    Result := 0;
  end;
end;

function TTextPadBlock.GetHeight: Integer;
begin
  try
    Result := FWidget.Canvas.TextHeight(UTF8Encode(Text));
  except
    Result := 0;
  end;
end;

function TTextPadBlock.GetRequiredWidth: Integer;
begin
  try
    Result := FWidget.Canvas.TextWidth(UTF8Encode(TrimRight(Text)));
  except
    Result := 0;
  end;
end;

function TTextPadBlock.GetSource: TTextPadObject;
begin
  Result := TTextPadObject(inherited Source);
end;

function TTextPadBlock.GetText: UnicodeString;
begin
  Result := Copy(Source.Text, FStartPos, FLen);
end;

function TTextPadBlock.XToCharPos(x: Integer): Integer;
var
  CharsFit, Extra, NextPos, NextCharWidth: Integer;
  s: UnicodeString;
  Size: TSize;
  Extents: array of Integer;
begin
  if FLen > 0 then
  begin
    s := Text;
    SetLength(Extents, FLen);
    {$HINTS OFF}
    Assert( GetTextExtentExPointW(FWidget.Canvas.Handle, PWideChar(s), FLen, x, @CharsFit, PInteger(Extents), Size) );
    {$HINTS ON}
    Assert( CharsFit >= 0 );
    Assert( CharsFit <= FLen );

    if CharsFit = FLen then
      Result := FLen
    else
    begin
      NextPos := GetAdjacentCharPos(CharsFit, TRUE);
      if NextPos = -1 then
        NextPos := FLen;
      NextCharWidth := FWidget.Canvas.TextWidth(UTF8Encode(Copy(s, CharsFit+1, NextPos - CharsFit)));

      if CharsFit = 0 then
        Extra := x
      else
        Extra := x - Extents[CharsFit-1];

      if Extra > NextCharWidth div 2 then
        Result := NextPos
      else
        Result := CharsFit;
    end;
  end
  else
    Result := 0;
end;

{ TGraphicPadBlock }

constructor TGraphicPadBlock.Create(Source: TPadObject;
  Widget: TPadWidget);
var
  g: TGraphicPadObject;
begin
  inherited Create(Source, Widget);
  try
    g := Source as TGraphicPadObject;
    FWidth := ObtainCachedImage(g).Width;
    FHeight := ObtainCachedImage(g).Height;

    if g.ImageFormat = 'JPEG' then
      FExtension := 'jpg'
    else
      FExtension := LowerCase(g.ImageFormat);

    FValidImage := TRUE;
  except
    FWidth := BAD_IMAGE_PLACEHOLDER_SIZE;
    FHeight := BAD_IMAGE_PLACEHOLDER_SIZE;
    FExtension := '';
    FValidImage := FALSE;
  end;
end;

procedure TGraphicPadBlock.Draw(Canvas: TCanvas; const p: TPoint; SelStart, SelLength: Integer);
var
  d: TSize;
  uh, dh, hs: Integer;
  Drawn: Boolean;
begin
  inherited;
  hs := GetHorizontalSpacing;

  if FValidImage then
  begin
    try
      Canvas.Draw(p.x + hs, p.y, ObtainCachedImage(Source));
      Drawn := TRUE;
    except
      Drawn := FALSE;
    end;
  end
  else
    Drawn := FALSE;

  if not Drawn then
  begin
    Canvas.Brush.Color := BAD_IMAGE_PLACEHOLDER_COLOR;
    Canvas.FillRect(Rect(p.x + hs, p.y, p.x + hs + FWidth, p.y + FHeight));
  end;

  if (SelLength > 0) and FWidget.Focused then
  begin
    d.cx := FWidth;
    d.cy := FHeight;
    InvertRect(Canvas.Handle, Rect(p.x + hs, p.y, p.x + hs + d.cx, p.y + d.cy));
    FWidget.GetSpacingsForLine(FLine.FIndex, uh, dh);
    Canvas.Brush.Color := FWidget.Color xor $ffffff;
    if uh > 0 then
      Canvas.FillRect(Rect(p.x, p.y - uh, p.x + 2*hs + d.cx, p.y));
    if dh > 0 then
      Canvas.FillRect(Rect(p.x, p.y + d.cy, p.x + 2*hs + d.cx, p.y + d.cy + dh));
    Canvas.FillRect(Rect(p.x, p.y - uh, p.x + hs, p.y + d.cy + dh));
    Canvas.FillRect(Rect(p.x + hs + d.cx, p.y - uh, p.x + 2*hs + d.cx, p.y + d.cy + dh));
  end;
end;

function TGraphicPadBlock.GetCharCount: Integer;
begin
  Result := 1;
end;

function TGraphicPadBlock.XToCharPos(x: Integer): Integer;
begin
  if x > FWidth div 2 then
    Result := 1
  else
    Result := 0;
end;

function TGraphicPadBlock.GetHeight: Integer;
begin
  Result := FHeight;
end;

function TGraphicPadBlock.GetHorizontalSpacing: Integer;
begin
  Result := 2;
end;

function TGraphicPadBlock.GetRequiredWidth: Integer;
begin
  Result := FWidth + 2*GetHorizontalSpacing;
end;

function TGraphicPadBlock.GetSource: TGraphicPadObject;
begin
  Result := TGraphicPadObject(inherited Source);
end;

end.

